home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / proportion-bar.lisp < prev    next >
Encoding:
Text File  |  1992-03-26  |  5.7 KB  |  177 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
  2.  
  3. (in-package :cl-user)
  4.  
  5. #|
  6.  
  7. Proportion-bar defines a subclass of simple-view that shows a bar in which the size
  8. of each of k regions is proportional to the magnitude of some parameter.  This can be
  9. used, for example, to show the relative likelihoods of a set of mutually exclusive
  10. and exhaustive possibilities.  The methods used by this are:
  11.  
  12. proportion-bar-n v    -- number of values to be displayed
  13. proportion-bar-val v i    -- i'th value, on a scale from 0.0 to 1.0; all must sum to 1.0
  14. proportion-bar-pat v i    -- pen pattern for this value; defaults to a selection from
  15.                {white, light-gray, gray, dark-gray, black} patterns
  16. proportion-bar-color v i -- color value (as in make-color) for the bar; default black
  17.  
  18. |#
  19.  
  20. (export '(proportion-bar))
  21.  
  22. (defclass proportion-bar (simple-view)
  23.   ()
  24.   )
  25.  
  26. (defmethod proportion-bar-n ((v proportion-bar))
  27.   1)
  28.  
  29. (defmethod proportion-bar-val ((v proportion-bar) i)
  30.   (declare (ignore i))
  31.   (/ 1.0 (proportion-bar-n v)))
  32.  
  33. (defparameter *defined-patterns*
  34.   (list *white-pattern* *light-gray-pattern* *gray-pattern* 
  35.         *dark-gray-pattern* *black-pattern*))
  36.  
  37. (defmethod proportion-bar-pat ((v proportion-bar) i)
  38.   (let ((n (proportion-bar-n v)))
  39.     (assert (> n 0) (n) "Proportion-bar-n of ~s (~d) must be > 0." v n)
  40.     (case n
  41.       (1 *black-pattern*)
  42.       (2 (if (zerop i) *white-pattern* *black-pattern*))
  43.       (3 (ccase i
  44.            (0 *white-pattern*)
  45.            (1 *gray-pattern*)
  46.            (2 *black-pattern*)))
  47.       (4 (ccase i
  48.            (0 *white-pattern*)
  49.            (1 *light-gray-pattern*)
  50.            (2 *dark-gray-pattern*)
  51.            (3 *black-pattern*)))
  52.       (otherwise (nth (mod i 5) *defined-patterns*)))))    
  53.  
  54. (defmethod proportion-bar-color ((v proportion-bar) i)
  55.   (declare (ignore i))
  56.   *black-color*)
  57.  
  58. (defmethod view-draw-contents ((v proportion-bar))
  59.   (let* ((sz (view-size v))
  60.          (s-h (point-h sz))
  61.          (s-v (point-v sz))
  62.          (n (proportion-bar-n v))
  63.          (horiz? (> s-h s-v))
  64.          (max (if horiz? s-h s-v))
  65.          )
  66.     (with-focused-view v
  67.       (rlet ((r :rect))
  68.         (do ((i 0 (1+ i))
  69.              (cum 0.0)
  70.              (beg 0 end)
  71.              (end))
  72.             ((>= i n))
  73.           (declare (float cum))
  74.           (setq end (round (* max (setq cum (+ cum (proportion-bar-val v i))))))
  75.           (setf (pref r rect.topleft) 
  76.                 (if horiz? (make-point beg 0) (make-point 0 beg)))
  77.           (setf (pref r rect.bottomright)
  78.                 (if horiz? (make-point end s-v) (make-point s-h end)))
  79.           (with-fore-color (proportion-bar-color v i)
  80.             (#_FillRect r (proportion-bar-pat v i)))
  81.           (cond (horiz? (#_MoveTo beg 0) (#_LineTo beg s-v))
  82.                 (t (#_MoveTo 0 beg) (#_LineTo s-h beg))))
  83.         (setf (pref r rect.topleft) #@(0 0))
  84.         (setf (pref r rect.bottomright) sz)
  85.         (#_FrameRect r)))))
  86.  
  87. #| A very simple example:
  88.  
  89. ;; Initially, we just define a vertical and a horizontal bar, using the default
  90. ;; pattern selections for display.
  91.  
  92. (defclass example-bar (proportion-bar)
  93.   ((vals :accessor vals :initarg :vals)))
  94.  
  95. (defmethod proportion-bar-n ((b example-bar))
  96.   (length (vals b)))
  97.  
  98. (defmethod proportion-bar-val ((b example-bar) i)
  99.   (nth i (vals b)))
  100.  
  101. (defmethod initialize-instance :after ((b example-bar) &rest foo)
  102.   (declare (ignore foo))
  103.   (let ((tot (float (apply #'+ (vals b)))))
  104.     (do ((vl (vals b) (cdr vl)))
  105.         ((null vl))
  106.       (setf (car vl) (/ (car vl) tot)))
  107.     b))
  108.  
  109. (defparameter w (make-instance 'window 
  110.                   :window-title "Proportion-bar test"
  111.                   :color-p t))
  112.  
  113. (defparameter b1 (make-instance 'example-bar
  114.                    :view-size #@(16 50)
  115.                    :view-position #@(3 3)
  116.                    :vals '(1 2 3 4)))
  117.  
  118. (defparameter b2 (make-instance 'example-bar
  119.                    :view-size #@(100 16)
  120.                    :view-position #@(29 3)
  121.                    :vals '(3 5)))
  122.  
  123. (add-subviews w b1 b2)
  124.  
  125. ;; Here we add overall color to the bar class; we get just a normal bar, except
  126. ;; all in the specified color.
  127.  
  128. (defclass color-example-bar (example-bar)
  129.   ((color :accessor color :initarg :color)))
  130.  
  131. (defmethod proportion-bar-color ((v color-example-bar) i)
  132.   (declare (ignore i))
  133.   (color v))
  134.  
  135. (defmethod view-draw-contents ((v color-example-bar))
  136.   (with-fore-color (color v)
  137.     (call-next-method)))
  138.  
  139. (defparameter b3 (make-instance 'color-example-bar
  140.                    :view-size #@(200 30)
  141.                    :view-position #@(40 50)
  142.                    :color *red-color*
  143.                    :vals '(.1 .2 .1 .2 .1 .1 .2)))
  144.  
  145. (add-subviews w b3)
  146.  
  147. ;; Finally, we create a bar whose regions are drawn in various solid shades of the
  148. ;; given color, instead of in patterns.
  149.  
  150. (defclass shade-example-bar (color-example-bar) ())
  151.  
  152. (defmethod proportion-bar-pat ((v shade-example-bar) i)
  153.   (declare (ignore i))
  154.   *black-pattern*)
  155.  
  156. (defmethod proportion-bar-color ((v shade-example-bar) i)
  157.   (let* ((col (color v))
  158.          (cr (color-red col))
  159.          (cg (color-green col))
  160.          (cb (color-blue col))
  161.          (n (proportion-bar-n v))
  162.          (mul (if (= n 1) 1.0 (/ (float i) (1- n)))))
  163.     ;; Note that 65280 is the magic number that is the intensity of r, g and b
  164.     ;; in *white-color*; in principle this should be 65536 (according to the manual)
  165.     ;; but that doesn't work, at least in MCL 2.0f2.
  166.     (flet ((interp (c) (+ 65280 (round (* mul (- c 65280))))))
  167.       (make-color (interp cr) (interp cg) (interp cb)))))
  168.  
  169. (defparameter b4 (make-instance 'shade-example-bar
  170.                    :view-size #@(200 20)
  171.                    :view-position #@(30 100)
  172.                    :color *dark-green-color*
  173.                    :vals '(.1 .2 .1 .2 .1 .1 .2)))
  174.  
  175. (add-subviews w b4)
  176.  
  177. |#